home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / slots.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-08-29  |  59.7 KB  |  1,330 lines
  1. ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. ;;;
  31. ;;; These four functions work on std-instances and fsc-instances.  These are
  32. ;;; instances for which it is possible to change the wrapper and the slots.
  33. ;;;
  34. ;;; For these kinds of instances, most specified methods from the instance
  35. ;;; structure protocol are promoted to the implementation-specific class
  36. ;;; std-class.  Many of these methods call these four functions.
  37. ;;;
  38.  
  39. (defun wrapper-error (&optional (object () object-p))
  40.   (if object-p
  41.       (error "What kind of instance is this: ~S" object)
  42.     (error "What kind of instance is this?")))
  43.  
  44. (defmacro get-slots (inst &optional (else-clause '(wrapper-error)))
  45.   (once-only (inst)
  46.     `(cond ((std-instance-p ,inst)      (std-instance-slots ,inst))
  47.            ((fsc-instance-p ,inst)      (fsc-instance-slots ,inst))
  48.            #+pcl-user-instances
  49.            ((get-user-instance-p ,inst) (get-user-instance-slots ,inst))
  50.            (T ,else-clause))))
  51.  
  52. (defmacro get-slots-or-nil (inst)
  53.   `(get-slots ,inst nil))
  54.  
  55. (defun set-wrapper (inst new)
  56.   (cond ((std-instance-p inst)
  57.          (setf (std-instance-wrapper inst) new))
  58.         ((fsc-instance-p inst)
  59.          (setf (fsc-instance-wrapper inst) new))
  60.         #+pcl-user-instances
  61.         ((user-instance-p inst)
  62.          (setf (user-instance-wrapper inst) new))
  63.         (t
  64.          (wrapper-error inst))))
  65.  
  66. (defun set-slots (inst new)
  67.   (cond ((std-instance-p inst)
  68.          (setf (std-instance-slots inst) new))
  69.         ((fsc-instance-p inst)
  70.          (setf (fsc-instance-slots inst) new))
  71.         #+pcl-user-instances
  72.         ((user-instance-p inst)
  73.          (setf (user-instance-slots inst) new))
  74.         (t
  75.          (wrapper-error inst))))
  76.  
  77.  
  78.  
  79. (defmacro get-class-slot-value-1 (object wrapper slot-name
  80.                                   &optional
  81.                                   (ignore-unbound-p NIL)
  82.                                   (ignore-missing-p NIL)
  83.                                   (return-cons-p    NIL)
  84.                                   (operation        ''slot-value))
  85.   ;; Search for slot-name in the class-slots of the object, returning
  86.   ;; its value if found and the slot is bound, calling slot-unbound if
  87.   ;; it was unbound (unless ignore-unbound is T), and calling slot-missing
  88.   ;; if it wasn't found in the class slots at all.
  89.   (once-only (object slot-name)
  90.     `(block nil
  91.        (locally (declare #.*optimize-speed*)
  92.          (let ((slots-left (wrapper-class-slots ,wrapper)))
  93.            (tagbody
  94.                (if (null slots-left)
  95.                    (go loop-slot-missing))
  96.              begin-class-loop
  97.                (if (eq (caar slots-left) ,slot-name)
  98.                    ,(cond
  99.                       (return-cons-p
  100.                         `(progn
  101.                            (setf slots-left (car slots-left))
  102.                            (go return-slot-value)))
  103.                       (ignore-unbound-p
  104.                         `(progn
  105.                            (setf slots-left (cdar slots-left))
  106.                            (go return-slot-value)))
  107.                       (T
  108.                        `(if (eq (setf slots-left (cdar slots-left))
  109.                                 ',*slot-unbound*)
  110.                             (return
  111.                               (slot-unbound (wrapper-class ,wrapper)
  112.                                             ,object ,slot-name))
  113.                           (go return-slot-value)))))
  114.                (if (null (setf slots-left (cdr slots-left)))
  115.                    (go loop-slot-missing))
  116.                (go begin-class-loop)
  117.              loop-slot-missing
  118.                ,@(unless ignore-missing-p
  119.                   `((return (slot-missing (wrapper-class ,wrapper)
  120.                                           ,object
  121.                                           ,slot-name
  122.                                           ,operation))))
  123.              return-slot-value)
  124.            slots-left)))))
  125.  
  126. (defmacro set-class-slot-value-1 (object wrapper slot-name new-value)
  127.   ;; Search for slot-name in the class-slots of the object, setting it
  128.   ;; to new-value if found, calling slot-missing otherwise.
  129.   (once-only (object slot-name new-value)
  130.     `(block nil
  131.        (locally (declare #.*optimize-speed*)
  132.          (let ((slots-left (wrapper-class-slots ,wrapper)))
  133.            (tagbody
  134.                (if (null slots-left)
  135.                    (go loop-slot-missing))
  136.              begin-class-loop
  137.                (if (eq (caar slots-left) ,slot-name)
  138.                    (return (setf (cdar slots-left) ,new-value)))
  139.                (if (null (setf slots-left (cdr slots-left)))
  140.                    (go loop-slot-missing))
  141.                (go begin-class-loop)
  142.              loop-slot-missing
  143.                (return (slot-missing (wrapper-class ,wrapper)
  144.                                      ,object
  145.                                      ,slot-name
  146.                                      'setf
  147.                                      ,new-value))))))))
  148.  
  149. (defmacro slot-value-from-wrapper-and-slots
  150.           (object slot-name wrapper slots-layout slots get-slots-fn)
  151.   "Extra fast and ugly way to return the value of object's slot when given
  152.    its wrapper and possibly slots-layout and slots vector."
  153.   (once-only (wrapper)
  154.    `(block nil
  155.      (locally (declare #.*optimize-speed*)
  156.        (let ((slots-left ,(if slots-layout
  157.                               slots-layout
  158.                               `(wrapper-instance-slots-layout ,wrapper))))
  159.          (tagbody
  160.              (if slots-left
  161.                  (let ((index 0))
  162.                    (declare (type index index))
  163.                    (tagbody
  164.                      begin-local-loop
  165.                        (if (eq (car slots-left) ,slot-name)
  166.                            (if (eq (setf slots-left
  167.                                          (%svref
  168.                                            ,(if slots
  169.                                                 slots
  170.                                               `(,(or get-slots-fn 'get-slots)
  171.                                                 ,object))
  172.                                            index))
  173.                                    ',*slot-unbound*)
  174.                                  (go loop-slot-unbound)
  175.                              (go return-slot-value)))
  176.                        (setf index (the index (1+ index)))
  177.                        (if (null (setf slots-left (cdr slots-left)))
  178.                            (go check-class-loop))
  179.                        (go begin-local-loop))))
  180.            check-class-loop
  181.              (if (null (setf slots-left (wrapper-class-slots ,wrapper)))
  182.                  (go loop-slot-missing))
  183.            begin-class-loop
  184.              (if (eq (caar slots-left) ,slot-name)
  185.                  (if (eq (setf slots-left (cdar slots-left))
  186.                          ',*slot-unbound*)
  187.                      (go loop-slot-unbound)
  188.                      (go return-slot-value)))
  189.              (if (null (setf slots-left (cdr slots-left)))
  190.                  (go loop-slot-missing))
  191.              (go begin-class-loop)
  192.            loop-slot-missing
  193.              (return (slot-missing (wrapper-class ,wrapper)
  194.                                    ,object
  195.                                    ,slot-name
  196.                                    'slot-value))
  197.            loop-slot-unbound
  198.              (return (slot-unbound (wrapper-class ,wrapper) ,object ,slot-name))
  199.            return-slot-value)
  200.          slots-left)))))
  201.  
  202. (defmacro set-slot-value-from-wrapper-and-slots
  203.   (object slot-name wrapper slots-layout slots get-slots-fn new-value)
  204.   "Extra fast and ugly way to set the value of object's slot when given its
  205.    wrapper and possibly slots-layout and slots vector."
  206.   (once-only (wrapper new-value)
  207.    `(block nil
  208.      (locally (declare #.*optimize-speed*)
  209.        (let ((slots-left ,(if slots-layout
  210.                               slots-layout
  211.                               `(wrapper-instance-slots-layout ,wrapper))))
  212.          (tagbody
  213.              (if slots-left
  214.                  (let ((index 0))
  215.                    (declare (type index index))
  216.                    (tagbody
  217.                      begin-local-loop
  218.                        (if (eq (car slots-left) ,slot-name)
  219.                            (progn
  220.                              (setf (%svref ,(if slots
  221.                                                 slots
  222.                                               `(,(or get-slots-fn 'get-slots)
  223.                                                 ,object))
  224.                                            index)
  225.                                    ,new-value)
  226.                              (go return-slot-value)))
  227.                        (setf index (the index (1+ index)))
  228.                        (if (null (setf slots-left (cdr slots-left)))
  229.                            (go check-class-loop))
  230.                        (go begin-local-loop))))
  231.            check-class-loop
  232.              (if (null (setf slots-left (wrapper-class-slots ,wrapper)))
  233.                  (go loop-slot-missing))
  234.            begin-class-loop
  235.              (if (eq (caar slots-left) ,slot-name)
  236.                  (progn
  237.                    (setf (cdar slots-left) ,new-value)
  238.                    (go return-slot-value)))
  239.              (if (null (setf slots-left (cdr slots-left)))
  240.                  (go loop-slot-missing))
  241.              (go begin-class-loop)
  242.            loop-slot-missing
  243.              (return (slot-missing (wrapper-class ,wrapper)
  244.                                    ,object
  245.                                    ,slot-name
  246.                                    'setf
  247.                                    ,new-value))
  248.            return-slot-value)
  249.          ,new-value)))))
  250.  
  251. (defmacro slot-boundp-from-wrapper-and-slots
  252.           (object slot-name wrapper slots-layout slots get-slots-fn)
  253.   "Extra fast and ugly way to return whether object's slot is boundp when
  254.    given its wrapper and possibly slots-layout and slots vector."
  255.   (once-only (wrapper)
  256.    `(block nil
  257.      (locally (declare #.*optimize-speed*)
  258.        (let ((slots-left ,(if slots-layout
  259.                               slots-layout
  260.                               `(wrapper-instance-slots-layout ,wrapper))))
  261.          (tagbody
  262.              (if slots-left
  263.                  (let ((index 0))
  264.                    (declare (type index index))
  265.                    (tagbody
  266.                      begin-local-loop
  267.                        (when (eq (car slots-left) ,slot-name)
  268.                          (return
  269.                            (neq (%svref ,(if slots
  270.                                              slots
  271.                                            `(,(or get-slots-fn 'get-slots)
  272.                                              ,object))
  273.                                         index)
  274.                                 ',*slot-unbound*)))
  275.                        (setf index (the index (1+ index)))
  276.                        (if (null (setf slots-left (cdr slots-left)))
  277.                            (go check-class-loop))
  278.                        (go begin-local-loop))))
  279.            check-class-loop
  280.              (if (null (setf slots-left (wrapper-class-slots ,wrapper)))
  281.                  (go loop-slot-missing))
  282.            begin-class-loop
  283.              (when (eq (caar slots-left) ,slot-name)
  284.                (return (neq (cdar slots-left) ',*slot-unbound*)))
  285.              (if (null (setf slots-left (cdr slots-left)))
  286.                  (go loop-slot-missing))
  287.              (go begin-class-loop)
  288.            loop-slot-missing
  289.              (return (slot-missing (wrapper-class ,wrapper)
  290.                                    ,object
  291.                                    ,slot-name
  292.                                    'slot-value))))))))
  293.  
  294.  
  295. (defsetf slot-value-from-wrapper-and-slots
  296.          set-slot-value-from-wrapper-and-slots)
  297.  
  298. (defmethod class-slot-value ((class std-class) slot-name)
  299.   (let ((wrapper (class-wrapper class))
  300.         (prototype (class-prototype class)))
  301.     (get-class-slot-value-1 prototype wrapper slot-name)))
  302.  
  303. (defmethod (setf class-slot-value) (nv (class std-class) slot-name)
  304.   (let ((wrapper (class-wrapper class))
  305.         (prototype (class-prototype class)))
  306.     (set-class-slot-value-1 nv prototype wrapper slot-name)))
  307.  
  308.  
  309. ;;;
  310. ;;; The following highly optimized methods for accessing the slots
  311. ;;;   of standard instances and funcallable standard instances aren't
  312. ;;;   in the MOP, but it would be nice if they were...  - TL
  313. ;;;
  314.  
  315. (defmacro safe-funcallable-standard-instance-slot-value (instance slot-name)
  316.   "Highly-optimized macro for returning the slot-value of instances that
  317.    are guaranteed to be funcallable-standard-instances with normal slots."
  318.   (once-only (instance)
  319.     `(locally (declare #.*optimize-speed*)
  320.        (slot-value-from-wrapper-and-slots
  321.           ,instance ,slot-name
  322.           (fast-check-wrapper-validity ,instance fsc-instance-wrapper)
  323.           NIL NIL fsc-instance-slots))))
  324.  
  325. (defmacro set-safe-funcallable-standard-instance-slot-value
  326.           (instance slot-name new-value)
  327.   "Highly-optimized macro for setting the slot-value of instances that
  328.    are guaranteed to be funcallable-standard-instances with normal slots."
  329.   (once-only (instance)
  330.     `(locally (declare #.*optimize-speed*)
  331.        (setf (slot-value-from-wrapper-and-slots
  332.                 ,instance ,slot-name
  333.                 (fast-check-wrapper-validity ,instance fsc-instance-wrapper)
  334.                 NIL NIL fsc-instance-slots)
  335.              ,new-value))))
  336.  
  337. (defmacro safe-funcallable-standard-instance-slot-boundp (instance slot-name)
  338.   "Highly-optimized macro for checking whether a slot is bound for instances
  339.    that are guaranteed to be funcallable-standard-instances with normal slots."
  340.   (once-only (instance slot-name)
  341.     `(locally (declare #.*optimize-speed*)
  342.        (slot-boundp-from-wrapper-and-slots
  343.           ,instance ,slot-name
  344.           (fast-check-wrapper-validity ,instance fsc-instance-wrapper)
  345.           NIL NIL fsc-instance-slots))))
  346.  
  347. (defsetf safe-funcallable-standard-instance-slot-value
  348.          set-safe-funcallable-standard-instance-slot-value)
  349.  
  350.  
  351. (defmacro funcallable-standard-instance-slot-value (instance slot-name)
  352.   "Highly-optimized macro for returning the slot-value of instances that
  353.    are guaranteed to be funcallable-standard-instances."
  354.   (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
  355.          `(safe-funcallable-standard-instance-slot-value ,instance ,slot-name))
  356.         (*safe-to-use-slot-value-wrapper-optimizations-p*
  357.          (once-only (instance slot-name)
  358.           `(locally (declare #.*optimize-speed*)
  359.              (if *safe-to-use-slot-value-wrapper-optimizations-p*
  360.                  (safe-funcallable-standard-instance-slot-value ,instance ,slot-name)
  361.                  (accessor-slot-value ,instance ,slot-name)))))
  362.         (T `(accessor-slot-value ,instance ,slot-name))))
  363.  
  364. (defmacro set-funcallable-standard-instance-slot-value
  365.           (instance slot-name new-value)
  366.   "Highly-optimized macro for setting the slot-value of instances that
  367.    are guaranteed to be funcallable-standard-instances."
  368.   (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
  369.          `(setf (safe-funcallable-standard-instance-slot-value ,instance ,slot-name)
  370.                 ,new-value))
  371.         (*safe-to-use-set-slot-value-wrapper-optimizations-p*
  372.          (once-only (instance slot-name new-value)
  373.           `(locally (declare #.*optimize-speed*)
  374.              (if *safe-to-use-set-slot-value-wrapper-optimizations-p*
  375.                  (setf (safe-funcallable-standard-instance-slot-value
  376.                            ,instance ,slot-name)
  377.                        ,new-value)
  378.                  (setf (accessor-slot-value ,instance ,slot-name) ,new-value)))))
  379.         (T `(setf (accessor-slot-value ,instance ,slot-name) ,new-value))))
  380.  
  381. (defmacro funcallable-standard-instance-slot-boundp (instance slot-name)
  382.   "Highly-optimized macro for checking whether a slot is bound for instances
  383.    that are guaranteed to be funcallable-standard-instances."
  384.   (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
  385.          `(safe-funcallable-standard-instance-slot-boundp ,instance ,slot-name))
  386.         (*safe-to-use-slot-boundp-wrapper-optimizations-p*
  387.          (once-only (instance slot-name)
  388.           `(locally (declare #.*optimize-speed*)
  389.              (if *safe-to-use-slot-boundp-wrapper-optimizations-p*
  390.                  (safe-funcallable-standard-instance-slot-boundp ,instance ,slot-name)
  391.                  (accessor-slot-boundp ,instance ,slot-name)))))
  392.         (T `(accessor-slot-boundp ,instance ,slot-name))))
  393.  
  394. (defsetf funcallable-standard-instance-slot-value
  395.          set-funcallable-standard-instance-slot-value)
  396.  
  397.  
  398. (defmacro safe-standard-instance-slot-value (instance slot-name)
  399.   "Highly-optimized macro for returning the slot-value of instances that
  400.    are guaranteed to be standard instances with normal slots."
  401.   (once-only (instance)
  402.     `(locally (declare #.*optimize-speed*)
  403.        (slot-value-from-wrapper-and-slots
  404.           ,instance ,slot-name
  405.           (fast-check-wrapper-validity ,instance std-instance-wrapper)
  406.           NIL NIL std-instance-slots))))
  407.  
  408. (defmacro set-safe-standard-instance-slot-value (instance slot-name new-value)
  409.   "Highly-optimized macro for setting the slot-value of instances that
  410.    are guaranteed to be standard instances with normal slots."
  411.   (once-only (instance)
  412.     `(locally (declare #.*optimize-speed*)
  413.        (setf (slot-value-from-wrapper-and-slots
  414.                 ,instance ,slot-name
  415.                 (fast-check-wrapper-validity ,instance std-instance-wrapper)
  416.                 NIL NIL std-instance-slots)
  417.             ,new-value))))
  418.  
  419. (defmacro safe-standard-instance-slot-boundp (instance slot-name)
  420.   "Highly-optimized macro for checking whether a slot is bound for instances
  421.    that are guaranteed to be standard-instances with normal slots."
  422.   (once-only (instance slot-name)
  423.     `(locally (declare #.*optimize-speed*)
  424.        (slot-boundp-from-wrapper-and-slots
  425.           ,instance ,slot-name
  426.           (fast-check-wrapper-validity ,instance std-instance-wrapper)
  427.           NIL NIL std-instance-slots))))
  428.  
  429. (defsetf safe-standard-instance-slot-value set-safe-standard-instance-slot-value)
  430.  
  431. (defmacro standard-instance-slot-value (instance slot-name)
  432.   "Highly-optimized macro for returning the slot-value of instances that
  433.    are guaranteed to be standard-instances."
  434.   (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
  435.          `(safe-standard-instance-slot-value ,instance ,slot-name))
  436.         (*safe-to-use-slot-value-wrapper-optimizations-p*
  437.          (once-only (instance slot-name)
  438.           `(locally (declare #.*optimize-speed*)
  439.              (if *safe-to-use-slot-value-wrapper-optimizations-p*
  440.                  (safe-standard-instance-slot-value ,instance ,slot-name)
  441.                  (accessor-slot-value ,instance ,slot-name)))))
  442.         (T `(accessor-slot-value ,instance ,slot-name))))
  443.  
  444. (defmacro set-standard-instance-slot-value
  445.           (instance slot-name new-value)
  446.   "Highly-optimized macro for setting the slot-value of instances that
  447.    are guaranteed to be standard-instances."
  448.   (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
  449.          `(setf (safe-standard-instance-slot-value ,instance ,slot-name)
  450.                 ,new-value))
  451.         (*safe-to-use-set-slot-value-wrapper-optimizations-p*
  452.          (once-only (instance slot-name new-value)
  453.           `(locally (declare #.*optimize-speed*)
  454.              (if *safe-to-use-set-slot-value-wrapper-optimizations-p*
  455.                  (setf (safe-standard-instance-slot-value
  456.                            ,instance ,slot-name)
  457.                        ,new-value)
  458.                  (setf (accessor-slot-value ,instance ,slot-name) ,new-value)))))
  459.         (T `(setf (accessor-slot-value ,instance ,slot-name) ,new-value))))
  460.  
  461. (defmacro standard-instance-slot-boundp (instance slot-name)
  462.   "Highly-optimized macro for checking whether a slot is bound for instances
  463.    that are guaranteed to be standard-instances."
  464.   (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
  465.          `(safe-standard-instance-slot-boundp ,instance ,slot-name))
  466.         (*safe-to-use-slot-boundp-wrapper-optimizations-p*
  467.          (once-only (instance slot-name)
  468.           `(locally (declare #.*optimize-speed*)
  469.              (if *safe-to-use-slot-boundp-wrapper-optimizations-p*
  470.                  (safe-standard-instance-slot-boundp ,instance ,slot-name)
  471.                  (accessor-slot-boundp ,instance ,slot-name)))))
  472.         (T `(accessor-slot-boundp ,instance ,slot-name))))
  473.  
  474. (defsetf standard-instance-slot-value set-standard-instance-slot-value)
  475.  
  476.  
  477. #+pcl-user-instances
  478. (progn
  479. (defmacro safe-user-instance-slot-value (instance slot-name)
  480.   "Highly-optimized macro for returning the slot-value of instances that
  481.    are guaranteed to be user instances with normal slots."
  482.   (once-only (instance)
  483.     `(locally (declare #.*optimize-speed*)
  484.        (slot-value-from-wrapper-and-slots
  485.           ,instance ,slot-name
  486.           (fast-check-wrapper-validity ,instance get-user-instance-wrapper)
  487.           NIL NIL get-user-instance-slots))))
  488.  
  489. (defmacro set-safe-user-instance-slot-value (instance slot-name new-value)
  490.   "Highly-optimized macro for setting the slot-value of instances that
  491.    are guaranteed to be user instances with normal slots."
  492.   (once-only (instance)
  493.     `(locally (declare #.*optimize-speed*)
  494.        (setf (slot-value-from-wrapper-and-slots
  495.                 ,instance ,slot-name
  496.                 (fast-check-wrapper-validity ,instance get-user-instance-wrapper)
  497.                 NIL NIL get-user-instance-slots)
  498.             ,new-value))))
  499.  
  500. (defmacro safe-user-instance-slot-boundp (instance slot-name)
  501.   "Highly-optimized macro for checking whether a slot is bound for instances
  502.    that are guaranteed to be user-instances with normal slots."
  503.   (once-only (instance slot-name)
  504.     `(locally (declare #.*optimize-speed*)
  505.        (slot-boundp-from-wrapper-and-slots
  506.           ,instance ,slot-name
  507.           (fast-check-wrapper-validity ,instance get-user-instance-wrapper)
  508.           NIL NIL get-user-instance-slots))))
  509.  
  510. (defsetf safe-user-instance-slot-value set-safe-user-instance-slot-value)
  511.  
  512.  
  513. (defmacro user-instance-slot-value (instance slot-name)
  514.   "Highly-optimized macro for returning the slot-value of instances that
  515.    are guaranteed to be user-instances."
  516.   (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
  517.          `(safe-user-instance-slot-value ,instance ,slot-name))
  518.         (*safe-to-use-slot-value-wrapper-optimizations-p*
  519.          (once-only (instance slot-name)
  520.           `(locally (declare #.*optimize-speed*)
  521.              (if *safe-to-use-slot-value-wrapper-optimizations-p*
  522.                  (safe-user-instance-slot-value ,instance ,slot-name)
  523.                  (accessor-slot-value ,instance ,slot-name)))))
  524.         (T `(accessor-slot-value ,instance ,slot-name))))
  525.  
  526. (defmacro set-user-instance-slot-value
  527.           (instance slot-name new-value)
  528.   "Highly-optimized macro for setting the slot-value of instances that
  529.    are guaranteed to be user-instances."
  530.   (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
  531.          `(setf (safe-user-instance-slot-value ,instance ,slot-name) ,new-value))
  532.         (*safe-to-use-set-slot-value-wrapper-optimizations-p*
  533.          (once-only (instance slot-name new-value)
  534.           `(locally (declare #.*optimize-speed*)
  535.              (if *safe-to-use-set-slot-value-wrapper-optimizations-p*
  536.                  (setf (safe-user-instance-slot-value ,instance ,slot-name)
  537.                        ,new-value)
  538.                  (setf (accessor-slot-value ,instance ,slot-name) ,new-value)))))
  539.         (T `(setf (accessor-slot-value ,instance ,slot-name) ,new-value))))
  540.  
  541. (defmacro user-instance-slot-boundp (instance slot-name)
  542.   "Highly-optimized macro for checking whether a slot is bound for instances
  543.    that are guaranteed to be user-instances."
  544.   (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
  545.          `(safe-user-instance-slot-boundp ,instance ,slot-name))
  546.         (*safe-to-use-slot-boundp-wrapper-optimizations-p*
  547.          (once-only (instance slot-name)
  548.           `(locally (declare #.*optimize-speed*)
  549.              (if *safe-to-use-slot-boundp-wrapper-optimizations-p*
  550.                  (safe-user-instance-slot-boundp ,instance ,slot-name)
  551.                  (accessor-slot-boundp ,instance ,slot-name)))))
  552.         (T `(accessor-slot-boundp ,instance ,slot-name))))
  553.  
  554. (defsetf user-instance-slot-value set-user-instance-slot-value)
  555. ) #+pcl-user-instances
  556.  
  557. #+(and excl sun4) (values)  ;; Weird bug in Allegro CL 3.1.13.1 [Sun4] requires this.
  558.  
  559. (defun make-slot-symbol (slot-name type pname)
  560.   (unless (symbol-package slot-name)
  561.     (slot-symbol-error slot-name))
  562.   (setf (get slot-name pname)
  563.         (intern (format nil "~A::~A slot ~a" 
  564.                         (package-name (symbol-package slot-name))
  565.                         (symbol-name slot-name)
  566.                         type)
  567.                 *slot-accessor-name-package*)))
  568.  
  569. (defmacro slot-symbol (slot-name type pname)
  570.   (once-only (slot-name)
  571.     `(if (symbolp ,slot-name)
  572.          (or (get ,slot-name ,pname)
  573.              (make-slot-symbol ,slot-name ,type ,pname))
  574.          (slot-symbol-error ,slot-name))))
  575.  
  576. (defun slot-symbol-error (slot-name)
  577.   (error "non-symbol slot-names (~S) are not yet implemented" slot-name))
  578.  
  579. (defmacro slot-reader-symbol (slot-name)
  580.   `(slot-symbol ,slot-name 'reader 'reader-slot-symbol))
  581.  
  582. (defmacro slot-writer-symbol (slot-name)
  583.   `(slot-symbol ,slot-name 'writer 'writer-slot-symbol))
  584.  
  585. (defmacro slot-boundp-symbol (slot-name)
  586.   `(slot-symbol ,slot-name 'boundp 'boundp-slot-symbol))
  587.  
  588. (defun find-slot-definition (class slot-name)
  589.   (declare #.*optimize-speed*)
  590.   (macrolet ((find-def (class-internal-slotds slot-name)
  591.                `(let ((ptr ,class-internal-slotds))
  592.                   (loop (when (null ptr)
  593.                           (return NIL))
  594.                         (when (eq (internal-slotd-name (car ptr)) ,slot-name)
  595.                           (return (internal-slotd-slot-definition (car ptr))))
  596.                         (setf ptr (cdr ptr))))))
  597.     (if (or (eq class *the-class-standard-class*)
  598.             (eq class *the-class-funcallable-standard-class*)
  599.             (eq class *the-class-standard-effective-slot-definition*))
  600.         (find-def (safe-standard-instance-slot-value class 'internal-slotds)
  601.                   slot-name)
  602.         (find-def (class-internal-slotds class) slot-name))))
  603.  
  604. (defun no-slot-accessor (object slot-name sym operation &optional new-value)
  605.   (if (and (not (or (std-instance-p  object)
  606.                     (fsc-instance-p  object)
  607.                     #+pcl-user-instances
  608.                     (user-instance-p object)))
  609.            (typep object 'structure))
  610.       (let ((structure-class (find-class (type-of object) nil)))
  611.         (if structure-class
  612.             (ecase operation
  613.               (slot-value  (slot-value object slot-name))
  614.               (setf        (setf (slot-value object slot-name) new-value))
  615.               (slot-boundp (slot-boundp object slot-name)))
  616.             (error
  617.               "Trying to do ~S for slot ~S on ~S, an instance of structure ~S
  618.                that was defined before PCL was loaded and that PCL can't make
  619.                a class for in this lisp."
  620.               (if (eq operation 'setf) '(setf slot-value) operation)
  621.               slot-name object (type-of object))))
  622.       (error "Trying to do ~S on ~S, but no class has a slot named ~S
  623.               (~s has no function binding) (or maybe your files were
  624.               compiled with an old version of PCL:  try recompiling.)"
  625.               (if (eq operation 'setf) '(setf slot-value) operation)
  626.               object slot-name sym)))
  627.  
  628. (defun no-slot-value-accessor (object slot-name sym)
  629.   (no-slot-accessor object slot-name sym 'slot-value))
  630.  
  631. (defun no-set-slot-value-accessor (object slot-name sym new-value)
  632.   (no-slot-accessor object slot-name sym 'setf new-value))
  633.  
  634. (defun no-slot-boundp-accessor (object slot-name sym)
  635.   (no-slot-accessor object slot-name sym 'slot-boundp))
  636.  
  637.  
  638. (defun slow-slot-value (object slot-name)
  639.   (let ((class (class-of object)))
  640.     (if (eq class *the-class-standard-effective-slot-definition*)
  641.         (safe-standard-instance-slot-value object slot-name)
  642.         (let ((slot-definition (find-slot-definition class slot-name)))
  643.           (if (null slot-definition)
  644.               (slot-missing class object slot-name 'slot-value)
  645.               (slot-value-using-class class object slot-definition))))))
  646.  
  647. (defmacro accessor-slot-value (object slot-name-form)
  648.   (if (and (constantp slot-name-form)
  649.            (let ((slot-name (eval slot-name-form)))
  650.              (and (symbolp slot-name) (symbol-package slot-name))))
  651.       (let* ((slot-name (eval slot-name-form))
  652.              (sym (slot-reader-symbol slot-name)))
  653.         (once-only (object)
  654.           `(if (fboundp ',sym)
  655.                (funcall-compiled (symbol-function ',sym) ,object)
  656.                (no-slot-value-accessor ,object ',slot-name ',sym))))
  657.       (let ((sym (gensym "READER-SYMBOL")))
  658.         (once-only (object slot-name-form)
  659.           `(let ((,sym (slot-reader-symbol ,slot-name-form)))
  660.              (declare (type symbol ,sym))
  661.              (if (fboundp ,sym)
  662.                  (funcall-compiled (symbol-function ,sym) ,object)
  663.                  (no-slot-value-accessor ,object ,slot-name-form ',sym)))))))
  664.  
  665. (defmacro wrapper-optimized-slot-value (object slot-name
  666.                                         &optional
  667.                                         (alternate-sv 'accessor-slot-value))
  668.   (once-only (object slot-name)
  669.     `(locally (declare #.*optimize-speed*)
  670.        (let ((wrapper NIL)
  671.              (slots   NIL))
  672.          (if (or (and (std-instance-p ,object)
  673.                       (setf wrapper (fast-check-wrapper-validity
  674.                                        ,object std-instance-wrapper))
  675.                       (setf slots (std-instance-slots ,object)))
  676.                  (and (fsc-instance-p ,object)
  677.                       (setf wrapper (fast-check-wrapper-validity
  678.                                       ,object fsc-instance-wrapper))
  679.                       (setf slots (fsc-instance-slots ,object)))
  680.                  #+pcl-user-instances
  681.                  (and (get-user-instance-p ,object)
  682.                       (setf wrapper (fast-check-user-wrapper-validity ,object))
  683.                       (setf slots (get-user-instance-slots ,object))))
  684.              (slot-value-from-wrapper-and-slots
  685.                ,object ,slot-name wrapper NIL slots NIL)
  686.              (,alternate-sv ,object ,slot-name))))))
  687.  
  688. (defmacro fast-slot-value (object slot-name
  689.                            &optional (alternate-sv 'accessor-slot-value))
  690.   "Optimized macro version of slot-value."
  691.   (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
  692.          `(wrapper-optimized-slot-value ,object ,slot-name ,alternate-sv))
  693.         (*safe-to-use-slot-value-wrapper-optimizations-p*
  694.          (once-only (object slot-name)
  695.           `(locally (declare #.*optimize-speed*)
  696.              (if *safe-to-use-slot-value-wrapper-optimizations-p*
  697.                  (wrapper-optimized-slot-value ,object ,slot-name ,alternate-sv)
  698.                  (,alternate-sv ,object ,slot-name)))))
  699.         (T `(,alternate-sv ,object ,slot-name))))
  700.  
  701. (defun slot-value (object slot-name)
  702.   (fast-slot-value object slot-name))
  703.  
  704. (define-compiler-macro slot-value (object-form slot-name-form)
  705.   `(fast-slot-value ,object-form ,slot-name-form))
  706.  
  707. (proclaim '(notinline unoptimized-slot-value))
  708.  
  709. (defun unoptimized-slot-value (object slot-name)
  710.   (fast-slot-value object slot-name))
  711.  
  712.  
  713. (defun slow-set-slot-value (object slot-name new-value)
  714.   (let* ((class (class-of object))
  715.          (slot-definition (find-slot-definition class slot-name)))
  716.     (if (null slot-definition)
  717.         (slot-missing class object slot-name 'setf)
  718.         (setf (slot-value-using-class class object slot-definition) new-value))))
  719.  
  720. (defsetf slow-slot-value slow-set-slot-value)
  721.  
  722. (defmacro accessor-set-slot-value (object slot-name-form new-value)
  723.   (if (and (constantp slot-name-form)
  724.            (let ((slot-name (eval slot-name-form)))
  725.              (and (symbolp slot-name) (symbol-package slot-name))))
  726.       (let* ((slot-name (eval slot-name-form))
  727.              (sym (slot-writer-symbol slot-name)))
  728.         (once-only (object new-value)
  729.           `(if (fboundp ',sym)
  730.                (funcall-compiled (symbol-function ',sym) ,new-value ,object)
  731.                (no-set-slot-value-accessor ,object ',slot-name ',sym ,new-value))))
  732.       (let ((sym (gensym "WRITER-SYM")))
  733.         (once-only (object new-value slot-name-form)
  734.           `(let ((,sym (slot-writer-symbol ,slot-name-form)))
  735.              (declare (type symbol ,sym))
  736.              (if (fboundp ,sym)
  737.                  (funcall-compiled (symbol-function ,sym) ,new-value ,object)
  738.                  (no-set-slot-value-accessor ,object ,slot-name-form ',sym
  739.                                              ,new-value)))))))
  740.  
  741. (defmacro wrapper-optimized-set-slot-value (object slot-name new-value
  742.                                             &optional
  743.                                             (alternate-sv
  744.                                               'accessor-slot-value))
  745.   (once-only (object slot-name)
  746.     `(locally (declare #.*optimize-speed*)
  747.        (let ((wrapper NIL)
  748.              (slots   NIL))
  749.          (if (or (and (std-instance-p ,object)
  750.                       (setf wrapper (fast-check-wrapper-validity
  751.                                        ,object std-instance-wrapper))
  752.                       (setf slots (std-instance-slots ,object)))
  753.                  (and (fsc-instance-p ,object)
  754.                       (setf wrapper (fast-check-wrapper-validity
  755.                                       ,object fsc-instance-wrapper))
  756.                       (setf slots (fsc-instance-slots ,object)))
  757.                  #+pcl-user-instances
  758.                  (and (get-user-instance-p ,object)
  759.                       (setf wrapper (fast-check-user-wrapper-validity ,object))
  760.                       (setf slots (get-user-instance-slots ,object))))
  761.              (setf (slot-value-from-wrapper-and-slots
  762.                      ,object ,slot-name wrapper NIL slots NIL)
  763.                    ,new-value)
  764.              (setf (,alternate-sv ,object ,slot-name) ,new-value))))))
  765.  
  766. (defmacro fast-set-slot-value (object slot-name new-value
  767.                                &optional
  768.                                (alternate-sv 'accessor-slot-value))
  769.   "Optimized macro version of set-slot-value."
  770.   (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
  771.          `(wrapper-optimized-set-slot-value ,object ,slot-name
  772.                                             ,new-value ,alternate-sv))
  773.         (*safe-to-use-slot-value-wrapper-optimizations-p*
  774.          (once-only (object slot-name new-value)
  775.           `(locally (declare #.*optimize-speed*)
  776.              (if *safe-to-use-slot-value-wrapper-optimizations-p*
  777.                  (wrapper-optimized-set-slot-value ,object ,slot-name
  778.                                                    ,new-value ,alternate-sv)
  779.                  (setf (,alternate-sv ,object ,slot-name) ,new-value)))))
  780.         (T `(setf (,alternate-sv ,object ,slot-name) ,new-value))))
  781.  
  782. (defmacro do-fast-set-slot-value (object slot-name new-value)
  783.   `(fast-set-slot-value ,object ,slot-name ,new-value))
  784.  
  785. (defsetf accessor-slot-value accessor-set-slot-value)
  786. (defsetf fast-slot-value do-fast-set-slot-value)
  787.  
  788.  
  789.  
  790. (defun set-slot-value (object slot-name new-value)
  791.   (fast-set-slot-value object slot-name new-value))
  792.  
  793. (define-compiler-macro set-slot-value (object-form slot-name-form new-value-form)
  794.   `(fast-set-slot-value ,object-form ,slot-name-form ,new-value-form))
  795.  
  796. (proclaim '(notinline unoptimized-set-slot-value))
  797.  
  798. (defun unoptimized-set-slot-value (object slot-name new-value)
  799.   (fast-set-slot-value object slot-name new-value))
  800.  
  801.  
  802. (eval-when (compile load eval)
  803. (defconstant *optimize-slot-boundp* nil))
  804.  
  805. (defun slow-slot-boundp (object slot-name)
  806.   (let* ((class (class-of object))
  807.          (slot-definition (find-slot-definition class slot-name)))
  808.     (if (null slot-definition)
  809.         (slot-missing class object slot-name 'slot-boundp)
  810.         (slot-boundp-using-class class object slot-definition))))
  811.  
  812. (defmacro accessor-slot-boundp (object slot-name-form)
  813.   (cond ((not *optimize-slot-boundp*)
  814.          `(slow-slot-boundp ,object ,slot-name-form))
  815.         ((and (constantp slot-name-form)
  816.               (let ((slot-name (eval slot-name-form)))
  817.                 (and (symbolp slot-name) (symbol-package slot-name))))
  818.          (let* ((slot-name (eval slot-name-form))
  819.                 (sym (slot-boundp-symbol slot-name)))
  820.            (once-only (object)
  821.               `(if (fboundp ',sym)
  822.                    (funcall-compiled (symbol-function ',sym) ,object)
  823.                    (no-slot-boundp-accessor ,object ',slot-name ',sym)))))
  824.         (T
  825.          (let ((sym (gensym "BOUNDP-SYM")))
  826.            (once-only (object slot-name-form)
  827.              `(let ((,sym (slot-boundp-symbol ,slot-name-form)))
  828.                 (declare (type symbol ,sym))
  829.                 (if (fboundp ,sym)
  830.                     (funcall-compiled (symbol-function ,sym) ,object)
  831.                     (no-slot-boundp-accessor ,object ,slot-name-form ',sym))))))))
  832.  
  833. (defmacro wrapper-optimized-slot-boundp (object slot-name
  834.                                         &optional
  835.                                         (alternate-sv 'accessor-slot-boundp))
  836.   (once-only (object slot-name)
  837.     `(locally (declare #.*optimize-speed*)
  838.        (let ((wrapper NIL)
  839.              (slots   NIL))
  840.          (if (or (and (std-instance-p ,object)
  841.                       (setf wrapper (fast-check-wrapper-validity
  842.                                        ,object std-instance-wrapper))
  843.                       (setf slots (std-instance-slots ,object)))
  844.                  (and (fsc-instance-p ,object)
  845.                       (setf wrapper (fast-check-wrapper-validity
  846.                                       ,object fsc-instance-wrapper))
  847.                       (setf slots (fsc-instance-slots ,object)))
  848.                  #+pcl-user-instances
  849.                  (and (get-user-instance-p ,object)
  850.                       (setf wrapper (fast-check-user-wrapper-validity ,object))
  851.                       (setf slots (get-user-instance-slots ,object))))
  852.              (slot-boundp-from-wrapper-and-slots
  853.                ,object ,slot-name wrapper NIL slots NIL)
  854.              (,alternate-sv ,object ,slot-name))))))
  855.  
  856. (defmacro fast-slot-boundp (object slot-name
  857.                            &optional (alternate-sv 'accessor-slot-boundp))
  858.   "Optimized macro version of slot-boundp."
  859.   (cond (*always-safe-to-use-slot-wrapper-optimizations-p*
  860.          `(wrapper-optimized-slot-boundp ,object ,slot-name ,alternate-sv))
  861.         (*safe-to-use-slot-boundp-wrapper-optimizations-p*
  862.          (once-only (object slot-name)
  863.           `(locally (declare #.*optimize-speed*)
  864.              (if *safe-to-use-slot-boundp-wrapper-optimizations-p*
  865.                  (wrapper-optimized-slot-boundp ,object ,slot-name ,alternate-sv)
  866.                  (,alternate-sv ,object ,slot-name)))))
  867.         (T `(,alternate-sv ,object ,slot-name))))
  868.  
  869. (defun slot-boundp (object slot-name)
  870.   (fast-slot-boundp object slot-name))
  871.  
  872. (define-compiler-macro slot-boundp (object-form slot-name-form)
  873.   `(fast-slot-boundp ,object-form ,slot-name-form))
  874.  
  875.  
  876. (defun slot-makunbound (object slot-name)
  877.   (let* ((class (class-of object))
  878.          (slot-definition (find-slot-definition class slot-name)))
  879.     (if (null slot-definition)
  880.         (slot-missing class object slot-name 'slot-makunbound)
  881.         (slot-makunbound-using-class class object slot-definition))))
  882.  
  883. (defun slot-exists-p (object slot-name)
  884.   (let* ((class (class-of object))
  885.          (slot-definition (find-slot-definition class slot-name)))
  886.     (and slot-definition
  887.          (slot-exists-p-using-class class object slot-definition))))
  888.  
  889. ;;;
  890. ;;; This isn't documented, but is used within PCL in a number of print
  891. ;;; object methods (see named-object-print-function).
  892. ;;; 
  893. (defun slot-value-or-default (object slot-name &optional (default "unbound"))
  894.   (if (slot-boundp object slot-name)
  895.       (slot-value object slot-name)
  896.       default))
  897.  
  898.  
  899. ;;;
  900. ;;; 
  901. ;;; 
  902. (defun standard-instance-access (instance location)
  903.   (%svref (std-instance-slots instance) location))
  904.  
  905. (defun funcallable-standard-instance-access (instance location)
  906.   (%svref (fsc-instance-slots instance) location))
  907.  
  908. (defun set-standard-instance-access (instance location new-value)
  909.   (setf (%svref (std-instance-slots instance) location) new-value))
  910.  
  911. (defun set-funcallable-standard-instance-access (instance location new-value)
  912.   (setf (%svref (fsc-instance-slots instance) location) new-value))
  913.  
  914. (defsetf standard-instance-access set-standard-instance-access)
  915. (defsetf funcallable-standard-instance-access set-funcallable-standard-instance-access)
  916.  
  917. #+pcl-user-instances
  918. (defun user-instance-access (instance location)
  919.   (%svref (user-instance-slots instance) location))
  920.  
  921. #+pcl-user-instances
  922. (defun set-user-instance-access (instance location new-value)
  923.   (setf (%svref (user-instance-slots instance) location) new-value))
  924.  
  925. #+pcl-user-instances
  926. (defsetf user-instance-access set-user-instance-access)
  927.  
  928. (defmethod slot-value-using-class ((class std-class)
  929.                                    (object standard-object)
  930.                                    (slotd standard-effective-slot-definition))
  931.   (let* ((location (slot-definition-location slotd))
  932.          (value (typecase location
  933.                   (fixnum 
  934.                    (cond ((std-instance-p object)
  935.                           (unless (eq 't (wrapper-state (std-instance-wrapper object)))
  936.                             (check-wrapper-validity object))
  937.                           (%svref (std-instance-slots object) location))
  938.                          ((fsc-instance-p object)
  939.                           (unless (eq 't (wrapper-state (fsc-instance-wrapper object)))
  940.                             (check-wrapper-validity object))
  941.                           (%svref (fsc-instance-slots object) location))
  942.                          #+pcl-user-instances
  943.                          ((user-instance-p object)
  944.                           (unless (eq 't (wrapper-state (user-instance-wrapper object)))
  945.                             (check-wrapper-validity object))
  946.                           (%svref (user-instance-slots object) location))
  947.                          (t (wrapper-error object))))
  948.                   (cons
  949.                    (cdr location))
  950.                   (t
  951.                    (error "The slot ~s has neither :instance nor :class allocation, ~@
  952.                            so it can't be read by the default ~s method."
  953.                           slotd 'slot-value-using-class)))))
  954.     (if (eq value *slot-unbound*)
  955.         (slot-unbound class object (slot-definition-name slotd))
  956.         value)))
  957.  
  958. (defmethod (setf slot-value-using-class)
  959.            (new-value (class std-class)
  960.                       (object standard-object)
  961.                       (slotd standard-effective-slot-definition))
  962.   (let ((location (slot-definition-location slotd)))
  963.     (typecase location
  964.       (fixnum 
  965.        (cond ((std-instance-p object)
  966.               (unless (eq 't (wrapper-state (std-instance-wrapper object)))
  967.                 (check-wrapper-validity object))
  968.               (setf (%svref (std-instance-slots object) location) new-value))
  969.              ((fsc-instance-p object)
  970.               (unless (eq 't (wrapper-state (fsc-instance-wrapper object)))
  971.                 (check-wrapper-validity object))
  972.               (setf (%svref (fsc-instance-slots object) location) new-value))
  973.              #+pcl-user-instances
  974.              ((user-instance-p object)
  975.               (unless (eq 't (wrapper-state (user-instance-wrapper object)))
  976.                 (check-wrapper-validity object))
  977.               (setf (%svref (user-instance-slots object) location) new-value))
  978.              (t (wrapper-error object))))
  979.       (cons
  980.        (setf (cdr location) new-value))
  981.       (t
  982.        (error "The slot ~s has neither :instance nor :class allocation, ~@
  983.                            so it can't be written by the default ~s method."
  984.               slotd '(setf slot-value-using-class))))))
  985.  
  986. (defmethod slot-boundp-using-class
  987.            ((class std-class) 
  988.             (object standard-object) 
  989.             (slotd standard-effective-slot-definition))
  990.   (let* ((location (slot-definition-location slotd))
  991.          (value (typecase location
  992.                   (fixnum 
  993.                    (cond ((std-instance-p object)
  994.                           (unless (eq 't (wrapper-state (std-instance-wrapper object)))
  995.                             (check-wrapper-validity object))
  996.                           (%svref (std-instance-slots object) location))
  997.                          ((fsc-instance-p object)
  998.                           (unless (eq 't (wrapper-state (fsc-instance-wrapper object)))
  999.                             (check-wrapper-validity object))
  1000.                           (%svref (fsc-instance-slots object) location))
  1001.                          #+pcl-user-instances
  1002.                          ((user-instance-p object)
  1003.                           (unless (eq 't (wrapper-state (user-instance-wrapper object)))
  1004.                             (check-wrapper-validity object))
  1005.                           (%svref (user-instance-slots object) location))
  1006.                          (t (wrapper-error object))))
  1007.                   (cons
  1008.                    (cdr location))
  1009.                   (t
  1010.                    (error "The slot ~s has neither :instance nor :class allocation, ~@
  1011.                            so it can't be read by the default ~s method."
  1012.                           slotd 'slot-boundp-using-class)))))
  1013.     (not (eq value *slot-unbound*))))
  1014.  
  1015. (defmethod slot-makunbound-using-class
  1016.            ((class std-class)
  1017.             (object standard-object) 
  1018.             (slotd standard-effective-slot-definition))
  1019.   (let ((location (slot-definition-location slotd)))
  1020.     (typecase location
  1021.       (fixnum 
  1022.        (cond ((std-instance-p object)
  1023.               (unless (eq 't (wrapper-state (std-instance-wrapper object)))
  1024.                 (check-wrapper-validity object))
  1025.               (setf (%svref (std-instance-slots object) location) *slot-unbound*))
  1026.              ((fsc-instance-p object)
  1027.               (unless (eq 't (wrapper-state (fsc-instance-wrapper object)))
  1028.                 (check-wrapper-validity object))
  1029.               (setf (%svref (fsc-instance-slots object) location) *slot-unbound*))
  1030.              #+pcl-user-instances
  1031.              ((user-instance-p object)
  1032.               (unless (eq 't (wrapper-state (user-instance-wrapper object)))
  1033.                 (check-wrapper-validity object))
  1034.               (setf (%svref (user-instance-slots object) location) *slot-unbound*))
  1035.              (t (wrapper-error object))))
  1036.       (cons
  1037.        (setf (cdr location) *slot-unbound*))
  1038.       (t
  1039.        (error "The slot ~s has neither :instance nor :class allocation, ~@
  1040.                            so it can't be written by the default ~s method."
  1041.               slotd 'slot-makunbound-using-class))))
  1042.   nil)
  1043.  
  1044. (defmethod slot-exists-p-using-class
  1045.            ((class std-class)
  1046.             (object standard-object)
  1047.             (slotd standard-effective-slot-definition))
  1048.   t)
  1049.  
  1050.  
  1051. (defmacro structure-instance-slot-value (instance slot-name)
  1052.   "Highly-optimized macro for returning the slot-value of instances that
  1053.    are guaranteed to be structure instances with normal slots."
  1054.   `(accessor-slot-value ,instance ,slot-name))
  1055.  
  1056. (defmacro set-structure-instance-slot-value (instance slot-name new-value)
  1057.   "Highly-optimized macro for setting the slot-value of instances that
  1058.    are guaranteed to be structure instances with normal slots."
  1059.   `(accessor-set-slot-value ,instance ,slot-name ,new-value))
  1060.  
  1061. (defmacro structure-instance-slot-boundp (instance slot-name)
  1062.   "Highly-optimized macro for checking whether a slot is bound for instances
  1063.    that are guaranteed to be structure-instances with normal slots."
  1064.   `(accessor-slot-boundp ,instance ,slot-name))
  1065.  
  1066. (defsetf structure-instance-slot-value set-structure-instance-slot-value)
  1067.  
  1068.  
  1069. (defmethod slot-value-using-class
  1070.     ((class structure-class)
  1071.      (object structure-object)
  1072.      (slotd structure-effective-slot-definition))
  1073.   (let ((function (slot-definition-internal-reader-function slotd)))
  1074.     (method-function-funcall function object)))
  1075.  
  1076. (defmethod (setf slot-value-using-class)
  1077.     (new-value (class structure-class)
  1078.                (object structure-object)
  1079.                (slotd structure-effective-slot-definition))
  1080.   (let ((function (slot-definition-internal-writer-function slotd)))
  1081.     (method-function-funcall function new-value object)))
  1082.  
  1083. (defmethod slot-boundp-using-class
  1084.            ((class structure-class) 
  1085.             (object structure-object)
  1086.             (slotd structure-effective-slot-definition))
  1087.   t)
  1088.  
  1089. (defmethod slot-makunbound-using-class
  1090.            ((class structure-class)
  1091.             (object structure-object)
  1092.             (slotd structure-effective-slot-definition))
  1093.   (error "Structure slots can't be unbound"))
  1094.  
  1095.  
  1096. (defmethod slot-missing
  1097.            ((class t) instance slot-name operation &optional new-value)
  1098.   (error "When attempting to ~A,~%the slot ~S is missing from the object ~S."
  1099.          (ecase operation
  1100.            (slot-value "read the slot's value (slot-value)")
  1101.            (setf (format nil
  1102.                          "set the slot's value to ~S (setf of slot-value)"
  1103.                          new-value))
  1104.            (slot-boundp "test to see if slot is bound (slot-boundp)")
  1105.            (slot-makunbound "make the slot unbound (slot-makunbound)"))
  1106.          slot-name
  1107.          instance))
  1108.  
  1109. (defmethod slot-unbound ((class t) instance slot-name)
  1110.   (error "The slot ~S is unbound in the object ~S." slot-name instance))
  1111.  
  1112.  
  1113. (defun structure-slot-boundp (object)
  1114.   (declare (ignore object))
  1115.   t)
  1116.  
  1117. (declaim (ftype (function (T T T) (values function boolean))
  1118.         get-optimized-std-accessor-method-function))
  1119. (defun get-optimized-std-accessor-method-function (class slotd name)
  1120.   (if (structure-class-p class)
  1121.       (values
  1122.         (ecase name
  1123.           (reader (slot-definition-internal-reader-function slotd))
  1124.           (writer (slot-definition-internal-writer-function slotd))
  1125.           (boundp #'structure-slot-boundp))
  1126.         nil)
  1127.       (let* ((instance-type (class-instance-type class))
  1128.              (slot-name (slot-definition-name slotd))
  1129.              (index (slot-definition-location slotd))
  1130.              (function (ecase name
  1131.                          (reader #'get-optimized-std-reader-method-function)
  1132.                          (writer #'get-optimized-std-writer-method-function)
  1133.                          (boundp #'get-optimized-std-boundp-method-function)))
  1134.              (value (funcall-function function instance-type slot-name index)))
  1135.         (values value (not (null index))))))
  1136.  
  1137. (defvar *optimized-std-reader-table* (make-hash-table :test 'equal))
  1138. (defvar *optimized-std-writer-table* (make-hash-table :test 'equal))
  1139. (defvar *optimized-std-boundp-table* (make-hash-table :test 'equal))
  1140.  
  1141. (defun get-optimized-std-reader-method-function (instance-type slot-name index)
  1142.   (etypecase index
  1143.     (fixnum
  1144.       (let ((table-index (list instance-type slot-name index)))
  1145.         (or (gethash table-index *optimized-std-reader-table*)
  1146.             (setf (gethash table-index *optimized-std-reader-table*)
  1147.                   (make-optimized-std-reader-method-function
  1148.                      instance-type slot-name index)))))
  1149.     (cons
  1150.       (make-optimized-std-reader-method-function
  1151.          instance-type slot-name index))))
  1152.  
  1153. (defun get-optimized-std-writer-method-function (instance-type slot-name index)
  1154.   (etypecase index
  1155.     (fixnum
  1156.       (let ((table-index (list instance-type slot-name index)))
  1157.         (or (gethash table-index *optimized-std-writer-table*)
  1158.             (setf (gethash table-index *optimized-std-writer-table*)
  1159.                   (make-optimized-std-writer-method-function
  1160.                      instance-type slot-name index)))))
  1161.     (cons
  1162.       (make-optimized-std-writer-method-function
  1163.          instance-type slot-name index))))
  1164.  
  1165. (defun get-optimized-std-boundp-method-function (instance-type slot-name index)
  1166.   (etypecase index
  1167.     (fixnum
  1168.       (let ((table-index (list instance-type slot-name index)))
  1169.         (or (gethash table-index *optimized-std-boundp-table*)
  1170.             (setf (gethash table-index *optimized-std-boundp-table*)
  1171.                   (make-optimized-std-boundp-method-function
  1172.                      instance-type slot-name index)))))
  1173.     (cons
  1174.       (make-optimized-std-boundp-method-function
  1175.          instance-type slot-name index))))
  1176.  
  1177. (defun make-optimized-std-reader-method-function (instance-type slot-name index)
  1178.   (declare #.*optimize-speed*)
  1179.   (set-function-name
  1180.    (etypecase index
  1181.      (fixnum (ecase instance-type
  1182.                (std-instance
  1183.                  #'(lambda (instance)
  1184.                      (let ((value (%svref (std-instance-slots instance) index)))
  1185.                        (if (eq value *slot-unbound*)
  1186.                            (slot-unbound (class-of instance) instance slot-name)
  1187.                            value))))
  1188.                (fsc-instance
  1189.                  #'(lambda (instance)
  1190.                      (let ((value (%svref (fsc-instance-slots instance) index)))
  1191.                        (if (eq value *slot-unbound*)
  1192.                            (slot-unbound (class-of instance) instance slot-name)
  1193.                            value))))
  1194.                #+pcl-user-instances
  1195.                (user-instance
  1196.                  (make-optimized-user-reader-method-function slot-name index))))
  1197.      (cons   #'(lambda (instance)
  1198.                  (let ((value (cdr index)))
  1199.                    (if (eq value *slot-unbound*)
  1200.                        (slot-unbound (class-of instance) instance slot-name)
  1201.                        value)))))
  1202.    `(reader ,slot-name)))
  1203.  
  1204. (defun make-optimized-std-writer-method-function (instance-type slot-name index)
  1205.   (declare #.*optimize-speed*)
  1206.   (set-function-name
  1207.    (etypecase index
  1208.      (fixnum (ecase instance-type
  1209.                (std-instance
  1210.                  #'(lambda (nv instance)
  1211.                      (setf (%svref (std-instance-slots instance) index) nv)))
  1212.                (fsc-instance
  1213.                  #'(lambda (nv instance)
  1214.                      (setf (%svref (fsc-instance-slots instance) index) nv)))
  1215.                #+pcl-user-instances
  1216.                (user-instance
  1217.                  (make-optimized-user-writer-method-function index))))
  1218.      (cons   #'(lambda (nv instance)
  1219.                  (declare (ignore instance))
  1220.                  (setf (cdr index) nv))))
  1221.    `(writer ,slot-name)))
  1222.  
  1223. (defun make-optimized-std-boundp-method-function (instance-type slot-name index)
  1224.   (declare #.*optimize-speed*)
  1225.   (set-function-name
  1226.    (etypecase index
  1227.      (fixnum (ecase instance-type
  1228.                (std-instance
  1229.                  #'(lambda (instance)
  1230.                      (not (eq *slot-unbound* 
  1231.                               (%svref (std-instance-slots instance) index)))))
  1232.                (fsc-instance
  1233.                  #'(lambda (instance)
  1234.                      (not (eq *slot-unbound*
  1235.                               (%svref (fsc-instance-slots instance) index)))))
  1236.                #+pcl-user-instances
  1237.                (user-instance
  1238.                  (make-optimized-user-boundp-method-function index))))
  1239.      (cons   #'(lambda (instance)
  1240.                  (declare (ignore instance))
  1241.                  (not (eq *slot-unbound* (cdr index))))))
  1242.    `(boundp ,slot-name)))
  1243.  
  1244. #+pcl-user-instances
  1245. (defun make-optimized-user-reader-method-function (slot-name index)
  1246.   (declare #.*optimize-speed*)
  1247.   (progn slot-name)
  1248.   #'(lambda (instance)
  1249.       (let ((value (%svref (user-instance-slots instance) index)))
  1250.         (if (eq value *slot-unbound*)
  1251.             (slot-unbound (class-of instance) instance slot-name)
  1252.             value))))
  1253.  
  1254. #+pcl-user-instances
  1255. (defun make-optimized-user-writer-method-function (index)
  1256.   (declare #.*optimize-speed*)
  1257.   #'(lambda (nv instance)
  1258.       (setf (%svref (user-instance-slots instance) index) nv)))
  1259.  
  1260. #+pcl-user-instances
  1261. (defun make-optimized-user-boundp-method-function (index)
  1262.   (declare #.*optimize-speed*)
  1263.   #'(lambda (instance)
  1264.       (not (eq *slot-unbound* (%svref (user-instance-slots instance) index)))))
  1265.  
  1266.  
  1267. (defvar *accessor-from-svuc-table* (make-hash-table :test 'equal))
  1268.  
  1269. (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
  1270.   (declare (type real-function sdfun))
  1271.   (let ((table-index (list class slotd sdfun name)))
  1272.     (or (gethash table-index *accessor-from-svuc-table*)
  1273.         (setf (gethash table-index *accessor-from-svuc-table*)
  1274.               (make-accessor-from-svuc-method-function
  1275.                  class slotd sdfun name)))))
  1276.  
  1277. (defun make-accessor-from-svuc-method-function (class slotd sdfun name)
  1278.   (declare #.*optimize-speed*)
  1279.   (declare (type real-function sdfun))
  1280.   (set-function-name
  1281.    (case name
  1282.      (reader #'(lambda (instance)
  1283.                  (method-function-funcall sdfun class instance slotd)))
  1284.      (writer #'(lambda (nv instance)
  1285.                  (method-function-funcall sdfun nv class instance slotd)))
  1286.      (boundp #'(lambda (instance)
  1287.                  (method-function-funcall sdfun class instance slotd))))
  1288.    `(,name ,(class-name class) ,(slot-definition-name slotd))))
  1289.  
  1290.  
  1291. (defun make-std-reader-method-function (slot-name)
  1292.   (declare #.*optimize-speed*)
  1293.   #'(lambda (instance)
  1294.       (fast-slot-value instance slot-name slow-slot-value)))
  1295.  
  1296. (defun make-std-writer-method-function (slot-name)
  1297.   (declare #.*optimize-speed*)
  1298.   #'(lambda (nv instance)
  1299.       (fast-set-slot-value instance slot-name nv slow-slot-value)))
  1300.  
  1301. (defun make-std-boundp-method-function (slot-name)
  1302.   (declare #.*optimize-speed*)
  1303.   #'(lambda (instance)
  1304.       (fast-slot-boundp instance slot-name slow-slot-boundp)))
  1305.  
  1306.  
  1307. (defun make-documented-std-reader-method-function (slot-name)
  1308.   (declare #.*optimize-speed*)
  1309.   #'(lambda (args next-methods)
  1310.       (declare (ignore next-methods))
  1311.       (let ((instance (car args)))
  1312.         (fast-slot-value instance slot-name slow-slot-value))))
  1313.  
  1314. (defun make-documented-std-writer-method-function (slot-name)
  1315.   (declare #.*optimize-speed*)
  1316.   #'(lambda (args next-methods)
  1317.       (declare (ignore next-methods))
  1318.       (let ((instance  (cadr args))
  1319.             (new-value (car args)))
  1320.         (fast-set-slot-value instance slot-name new-value slow-slot-value))))
  1321.  
  1322. (defun make-documented-std-boundp-method-function (slot-name)
  1323.   (declare #.*optimize-speed*)
  1324.   #'(lambda (args next-methods)
  1325.       (declare (ignore next-methods))
  1326.       (let ((instance (car args)))
  1327.         (fast-slot-boundp instance slot-name slow-slot-boundp))))
  1328.  
  1329.  
  1330.